\ utils.utf .. basic utilities for Jax4th
\ Copyright (c)1994 Jack J. Woehr
\ P.O. Box 51, Golden, Colorado 80402-0051
\ jax@well.sf.ca.us 72203.1320@compuserve.com
\ SYSOP RCFB (303) 278-0364 2400/9600/14400
\ All Rights Reserved
\ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\ This is free software and can be modified and redistributed under
\ certain conditions described in the file COPYING.TXT. The
\ Disclaimer of Warranty and License for this free software are also
\ contained in the file COPYING.TXT.
\ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

\
\ $Log: utils.f,v $
\ Revision 1.4  1994/08/26  15:30:43  jax
\ Fixed VOCABULARY.
\
\

\ Standard information:
\ A lot of the code in this file is very implementation dependent.
\

MARKER utils.utf

\ ~~~~~~~~~~~~~~~~~
\ General utilities
\ ~~~~~~~~~~~~~~~~~

DECIMAL

\ This is from the Toolkit wordset.
: .( [CHAR] ) PARSE TYPE ; IMMEDIATE

CR .( Loading Utilities) CR

\ Usage: INCLUDE path\path\filename.utf
: INCLUDE ( "ccc<>" -- ) BL WORD COUNT INCLUDED ;

\ The next two are from Forth history.
: DEFER CREATE ['] NOOP DOES> @ EXECUTE ;

\ Works on DEFER words.
: IS ( xt "name" <interp> | "name" <compiling> --)
  ' >BODY
  STATE @
  IF POSTPONE LITERAL POSTPONE !
  ELSE !
  THEN   ; IMMEDIATE

\ double constant
: DCONSTANT ( Compile: d|ud name --  Name Execute: -- d|ud)
   CREATE , , DOES> 2@ ;

\ cell array
: ARRAY ( n --)
   CREATE CELLS ALLOT
   DOES> ( n - i) SWAP CELLS + ;

\ Type a possibly null-terminated string
: 0TYPE ( c-addr u --)
    0
    ?DO
        DUP I CHARS +   \ -- c-addr c-addr'
        C@ ?DUP         \ -- c-addr char char|--
        IF              \ -- c-addr char
            EMIT        \ -- c-addr
        ELSE            \ -- c-addr
            LEAVE       \ -- c-addr
        THEN
    LOOP DROP           \ --
;

\ ~~~~~~~~~~~~~~~~~~~~~~~~
\ BLOCK loading extensions
\ ~~~~~~~~~~~~~~~~~~~~~~~~

\ Load relative to current contents of BLK
: +LOAD ( n --) BLK @ + LOAD ;                        
: +THRU ( n1 n2 --) BLK @ TUCK + >R + R> THRU ;

\ ~~~~~~~~~~~~
\ Search order
\ ~~~~~~~~~~~~

\ Set a reasonable order.
: USEFUL ( --)                                        
    SYSTEM-WORDLIST NONSTANDARD-WORDLIST FORTH-WORDLIST
    3 SET-ORDER DEFINITIONS ;

\ Analogous to ALSO but takes a wordlist identifier argument.
: ALSO-WID ( wid --)
    >R GET-ORDER R> SWAP 1+ SET-ORDER ;                

\ Set the order to include all the Jax4th system wordlists.
: ALL ( --) USEFUL INTERNALS-WORDLIST ALSO-WID ;
    

\ ~~~~~~~~~~~~~~~~~~~
\ Some Error Handling
\ ~~~~~~~~~~~~~~~~~~~

DECIMAL

\ Stick these error codes in the Nonstandard wordlist.
USEFUL NONSTANDARD-WORDLIST SET-CURRENT

-03 CONSTANT stack_under_throw
-37 CONSTANT file_io_throw
-50 CONSTANT search_order_underflow_throw
-256 CONSTANT sys_throw_0
-300 CONSTANT invalid_xt

\ check for sufficient args
: ?ENOUGH ( i*j n -- i*j | throw)
   DEPTH 1- > stack_under_throw AND THROW ;

\ ~~~~~~~~~~~~~~~~~~
\ Named vocabularies
\ ~~~~~~~~~~~~~~~~~~

USEFUL

: SET-CONTEXT ( wid --)
    >R GET-ORDER
    DUP 0= search_order_underflow_throw AND THROW
    NIP R> SWAP SET-ORDER ; \ /\/\ shd. == 0 THROW normally

INTERNALS-WORDLIST ALSO-WID

\ Create a named wordlist, then create a word of the same name emulating F83 VOCABULARY
: VOCABULARY ( "ccc< >" --)
    >IN @                           \ -- u, save pointer to input for recreating name
    BL WORD COUNT NAMEWORDLIST      \ -- u wid
    SWAP >IN !                      \ -- wid, restore input pointer for second create of same name
    ABSTODATA DATATOCODE            \ -- adr, this is a code-relative address
    CREATE ,                        \ -- create the named voc and save c-r-addr
    DOES> ( -- wid)
        @ CODETOABS SET-CONTEXT     \ -- at runtime, recalc wid from code-relative addr
;

\ ~~~~~~~~~~~~~~~~~~~~
\ More on ENVIRONMENT?
\ ~~~~~~~~~~~~~~~~~~~~

USEFUL HEX

\ Create a wordlist in which all the ENVIRONMENT? queries live.
S" ENVIRONMENT" NAMEWORDLIST DROP

\ A redefinition of ENVIRONMENT?
\ Maybe this should be moved back into the kernel
: ENVIRONMENT? ( c-addr u -- false | i*x true)
   ENVIRONMENT SEARCH-WORDLIST
   IF EXECUTE TRUE ELSE FALSE THEN ;

\ The constants found by the queries.
ENVIRONMENT ALSO-WID DEFINITIONS

\ These are all from dpANS-5 3.2.6
FFFD CONSTANT /COUNTED-STRING
  80 CONSTANT /HOLD
  80 CONSTANT /PAD
  08 CONSTANT ADDRESS-UNIT-BITS
TRUE CONSTANT CORE
FALSE CONSTANT CORE-EXT
FALSE CONSTANT FLOORED
FFFD CONSTANT MAX-CHAR
7FFFFFFFFFFFFFFF. DCONSTANT MAX-D
7FFFFFFF CONSTANT MAX-N
FFFFFFFF CONSTANT MAX-U
FFFFFFFFFFFFFFFF. DCONSTANT MAX-UD
1000 CONSTANT RETURN-STACK-CELLS \ may change
1000 CONSTANT STACK-CELLS   \ ditto

DECIMAL PREVIOUS DEFINITIONS

\ ~~~~~~~~~~~~~~
\ End of utils.f
\ ~~~~~~~~~~~~~~